home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / textyl / psrc / textyl.pas.ab < prev    next >
Text File  |  1993-11-07  |  25KB  |  1,001 lines
  1.  
  2. {---------------------------------------------------}  
  3. procedure Output4Byte (i : integer);
  4. var tmp : integer;
  5. begin
  6.   tmp := i;
  7.   if (tmp >= 0) then
  8.     begin
  9.     OutputByte (tmp div TWO24);
  10.     end
  11.   else
  12.     begin
  13.     tmp := tmp + TWO31 + 1; (* need the +1 *)
  14.     OutputByte (tmp div TWO24 + 128);
  15.     end; 
  16.   tmp := tmp mod TWO24;
  17.   OutputByte (tmp div TWO16);
  18.   tmp := tmp mod TWO16;
  19.   OutputByte (tmp div 256);
  20.   OutputByte (tmp mod 256);
  21. end;
  22.  
  23.  
  24. {---------------------------------------------------}
  25.  
  26. function rtan (ang : real) : real;
  27. var rads : real;
  28.     cosrads : real;
  29. begin
  30.   rads := ang * DEGTORAD;
  31.   cosrads := cos (rads);
  32.   if (cosrads = 0.0) then  { this happens at 90 and 270 }
  33.     cosrads := cos ((ang - 0.01) * DEGTORAD);
  34.   rtan := (sin (rads)) / (cosrads);
  35. end;
  36.  
  37. {---------------------------------------------------}
  38. function float (i : integer) : real;
  39. begin
  40.   float := i + 0.00;
  41. end;
  42.  
  43.  
  44. {---------------------------------------------------}
  45. function tolowercase (let: char) : char;
  46. const Diff = 32; (* xord['a'] - xord['A'] *)
  47. var olet : integer;
  48. begin
  49.  olet := xord[let];
  50.  if (olet >= xord['A']) then
  51.     begin
  52.     if (olet <= xord['Z']) then
  53.       begin
  54.       let := xchr[olet + Diff];
  55.       end;
  56.     end;
  57.  tolowercase := let;
  58. end;
  59.  
  60. {---------------------------------------------------}
  61. (* decide if the first string is the same as the second --
  62.  * at least the first 'len' characters 
  63.  *       We need this since most Pascal impls. are brain-dead
  64.  *       when it comes to string comparisons     
  65.  *)
  66. function streq (a, b : charstring; len : integer) : boolean;
  67. label 1;
  68. var i : integer;
  69.     same : boolean;
  70. begin
  71.   same := true;
  72.   for i := 1 to len do
  73.     begin
  74.     if (a[i] <> b[i]) then
  75.       begin
  76.       same := false;
  77.       goto 1;
  78.       end;  (* if *)
  79.     end;  (* for *)
  80. 1: 
  81.    streq := same;  
  82. end;  (* streq *)
  83.  
  84. {-------------------------------------------------------}
  85. procedure strcopy (* src : charstring; var dest : charstring; len : integer *);
  86. var i : integer;
  87.   begin
  88.   for i := 1 to len do
  89.     dest[i] := src[i];
  90.   end;  
  91.  
  92. {-------------------------------------------------------}
  93. procedure writestrng (* s :strng; tologfile : boolean *);
  94. var i : integer;
  95. begin
  96. if (tologfile) then
  97.   begin
  98.   for i := 1 to s.len do
  99.     write (logfile, s.str[i]);
  100.   end
  101. else
  102.   begin
  103.   for i := 1 to s.len do
  104.     write (s.str[i]);
  105.   end;
  106. end;
  107.  
  108.  
  109. {---------------------------------------------------}
  110. (* Move the current DVI position to posx, posy by 
  111.  * moving relatively from our current position
  112.  * and store the new position 
  113.  *)
  114.  
  115. procedure isetpos (posx, posy : integer);
  116. var dy, dx: ScaledPts;
  117.     numbytes : integer;
  118. begin
  119.    dx := posx - ourxpos;
  120.    dy := posy - ourypos;
  121.  
  122.    numbytes := 1;
  123.    if ((dx < 128) and (dx >= -128)) then
  124.       numbytes := 1
  125.    else if ((dx < 32768) and (dx >= -32768)) then
  126.       numbytes := 2
  127.    else if ((dx < TWO23) and (dx >= - TWO23))then
  128.       numbytes := 3
  129.    else if ((dx < TWO31) and (dx >= - TWO31))then
  130.       numbytes := 4
  131.    else
  132.       begin
  133.       complain (ERRREALBAD);
  134.       writeln('Panic: dx is too big/small in isetpos: ',dx);
  135.       writeln(logfile,'Panic: dx is too big/small in isetpos: ',dx);
  136.       end;
  137.   
  138.    cmd1byte (RIGHTLEFT + numbytes -1); (* number of bytes in its arg list *)
  139.    cmdSigned (dx, numbytes);
  140.     
  141.    numbytes := 1;
  142.    if ((dy < 128) and (dy >= -128)) then
  143.       numbytes := 1
  144.    else if ((dy < 32768) and (dy >= -32768)) then
  145.       numbytes := 2
  146.    else if ((dy < TWO23) and (dy >= - TWO23))then
  147.       numbytes := 3
  148.    else if ((dy < TWO31) and (dy >= - TWO31))then
  149.       numbytes := 4
  150.    else
  151.       begin
  152.       complain (ERRREALBAD);
  153.       writeln('Panic: dy is too big/small in isetpos: ',dy);
  154.       writeln(logfile,'Panic: dy is too big/small in isetpos: ',dy);
  155.       end;
  156.   
  157.    cmd1byte (DOWNUP + numbytes -1);
  158.   
  159.    cmdSigned (dy, numbytes);
  160.   
  161.    ourxpos := posx;
  162.    ourypos := posy;
  163. end;
  164.  
  165. {---------------------------------------------------}
  166. (* put out a character *)
  167. procedure iputchar (charno : OctByt);
  168. begin
  169.   cmd1byte (PUT1);
  170.   cmd1byte (charno);
  171. end;
  172.  
  173.  
  174. {---------------------------------------------------}
  175. (* set the font number, but only if it is different than
  176.  * the last one we accessed.
  177.  *)
  178. procedure isetfont (DVINum : integer);
  179. begin
  180.   if (ourfontnum <> DVINum) then
  181.     begin
  182.     cmd1byte (USEFONT);
  183.     cmd2byte (DVINum);
  184.     ourfontnum := DVINum;
  185.     end;
  186. end;
  187.  
  188.  
  189. procedure IPUSH;
  190. begin
  191.   if (ourpushdepth = 0) then
  192.     begin   (* first push --> start tyling *)
  193.     origTexfont := font[curfont].num;
  194.     end
  195.   else
  196.     begin
  197.     prevfont := ourfontnum; (* store the internal font number in use at this time *)
  198.     end;
  199.   cmd1byte (NOP);
  200.   cmd1byte (NOP); (* our greeting *)  
  201.   cmd1byte (PUSH);
  202.   ourpushdepth := ourpushdepth + 1;
  203. end;  
  204.  
  205. procedure IPOP;
  206. begin
  207.   cmd1byte (POP);
  208.   cmd1byte(NOP);
  209.   cmd1byte(NOP); (* our signature *)
  210.   ourpushdepth := ourpushdepth - 1;
  211.   if (ourpushdepth < 0) then
  212.     begin
  213.     complain (ERRREALBAD);
  214.     writeln(logfile,'Error: too many internal pops');
  215.     end;
  216.   if (ourpushdepth = 0) then
  217.     begin (* we are totally done with tyling for now *)
  218.     if (nf > 0) then
  219.       isetfont (origTexfont); (* only if it is valid *)
  220.     end
  221.   else
  222.     begin
  223.     if (prevfont >= 0) then 
  224.       isetfont(prevfont);     (* restore that internal font previously in use *)
  225.     end;
  226. end;  
  227.  
  228. {---------------------------------------------------}
  229. (* Assumes that the correct font is currently set *)
  230. procedure Tyldot (dotx, doty : ScaledPts);
  231. begin
  232.   if (dotx <> 0) and (doty <> 0) then
  233.     isetpos (dotx, doty);
  234.   iputchar (DOTCHAR);
  235. end;  
  236.  
  237. {---------------------------------------------------}
  238. procedure InitDVIBuf;
  239. var i: integer;
  240. begin
  241.   with GDVIBuf do
  242.     begin
  243.     TotByteLen := 0;
  244.     Numstrings := 0;
  245.     for i := 1 to MAXDVISTRINGS do
  246.       Dstrings[i] := nil;
  247.     curstrindex := MAXOLEN + 1;
  248.     end; 
  249. end;
  250.  
  251. {---------------------------------------------------}
  252. procedure ClearDVIBuf;
  253. var i : integer;
  254. begin
  255.   with GDVIBuf do
  256.     begin
  257.     for i := 1 to Numstrings do
  258.       begin
  259.       dispose (Dstrings[i]);
  260.       Dstrings[i] := nil;
  261.       end;
  262.     TotByteLen := 0;
  263.     Numstrings := 0;
  264.     curstrindex := MAXOLEN + 1;
  265.     end; 
  266. end;
  267.  
  268. {---------------------------------------------------}
  269. procedure WriteDVIBuf;
  270. var i: integer;
  271.     curstr: integer;
  272.     b : OctByt;
  273. begin
  274.   curstr := 1;
  275.   with GDVIBuf do
  276.     begin
  277.     while (curstr < Numstrings) do
  278.       begin
  279.       for i := 1 to MAXOLEN do
  280.         begin
  281.           b := Dstrings[curstr]^[i];
  282.           OutputByte (b);       
  283.         end;
  284.       curstr := curstr + 1;
  285.       end; (* while *)
  286.  
  287. (* now do the last string *)
  288.    for i := 1 to (curstrindex - 1) do
  289.      begin
  290.        b := Dstrings[Numstrings]^[i];
  291.        OutputByte(b);
  292.      end;  (* for *)
  293.     end;  (* with *)
  294.   ClearDVIBuf;
  295. end;
  296.  
  297. {---------------------------------------------------}
  298. procedure BackupInBuf (nbytes : integer);
  299. var nstrs, rem : integer;
  300. begin
  301.   with GDVIBuf do
  302.     begin
  303.     nstrs := (TotByteLen - nbytes) div MAXOLEN;
  304.     rem :=  (TotByteLen - nbytes) mod MAXOLEN;
  305.     Numstrings :=  nstrs + 1;
  306.     curstrindex := rem + 1; (* points to position to-be-filled *)
  307.     if (curstrindex = 0) then 
  308.        curstrindex := MAXOLEN;
  309.     TotByteLen := TotByteLen - nbytes;
  310.     end; 
  311. end;
  312.  
  313. {-----------------------------------------------------}
  314. function DVIMark : integer;
  315. begin
  316.   DVIMark := GDVIBuf.TotByteLen;
  317. end;  
  318.  
  319.  
  320.  
  321. {---------------------------------------------}
  322. function NewItem (what : Primitive): pItem;
  323. var i : pItem;
  324.     f : figptr;
  325. begin
  326.  
  327.  new (i);
  328.  with i^ do 
  329.    begin
  330.    nextitem := nil;
  331.    BBlx := 0;
  332.    BBby := 0;
  333.    BBrx := 0;
  334.    BBty := 0;
  335.    itemthick := LoVThick;
  336.    itemvec := VKCirc;
  337.    itempatt := solid;
  338.    kind := what;
  339.    case (what) of          (* give defaults *)
  340.      Aline : ;
  341.      Aspline:    begin
  342.         nsplknots := 0;
  343.         dosmarks := 0;
  344.         sclosed := false;
  345.         spltype := BSPL;
  346.         end;
  347.      Attspline:    begin
  348.         nttknots := 0;
  349.         dottmarks := 0;
  350.         tspltype := BSPL;
  351.         tclosed := false;
  352.         end;
  353.      Abeam : ;
  354.      Atieslur:    begin
  355.         ntknots := 0;
  356.         end;
  357.      Aarc:    begin
  358.         narcknots := 0;
  359.         end;         
  360.      Alabel:    begin
  361.              fontstyle := -1; (* undefined *)
  362.         labeltext.len := 0;
  363.         end;
  364.      Afigure:    begin    
  365.         figtheta := 0.0;
  366.         fsx := 1.0;     fsy := 1.0;
  367.         fdx := 0;       fdy := 0;
  368.         preWid := 0;    preHt := 0;
  369.         postWid := 0;   postHt := 0;
  370.         depthnumber := 0; (* for now *)
  371.         new (f); (* a new figure *)
  372.         body := f;
  373.         body^.things := nil;
  374.         end;
  375.      end; (*case *)
  376.    end;  (* with *)
  377.  NewItem := i;
  378. end;  (* NewItem *)
  379.  
  380. { ### Note: "pageitems" could be extended to be a list
  381. { of macrodefinitions which contain primitives , and
  382. { then could be instanced.  E.g., a library of common
  383. { figures callable from \special level }
  384.  
  385.  
  386. {------------------------------------------------------}
  387. procedure pushItem (depth : integer; newthing : pItem);
  388. label 101;
  389. var i, p : pItem;
  390.     dun : boolean;
  391. begin
  392.   if (pageitems = nil) then
  393.     begin
  394.     if (newthing^.kind = Afigure) then
  395.       begin
  396.       pageitems := newthing;
  397.       goto 101;
  398.       end
  399.     else
  400.       begin
  401.       pageitems := NewItem (Afigure);
  402.       pageitems^.depthnumber := depth;
  403.       end;
  404.     end;
  405.   
  406.   (* Assume that pageitems points to Afigure *)
  407.  
  408.       (* traverse the list *)
  409.       i := pageitems; (* point to front of list for now *)
  410.       p := i^.body^.things; 
  411.       dun := false;
  412.       while ((p <> nil) and not dun) do
  413.         begin
  414.         if (depth = i^.depthnumber) then
  415.           begin (* simple push *)
  416.           dun := true;
  417.           (* Note: this is the case when pushing another figure item
  418.                 onto an already-existing list. We push the newfigure
  419.                 with a depth of (fig^.depthnumber - 1) because it
  420.                 really is part of the higer-level figure
  421.            *)
  422.           end
  423.         else if (depth > i^.depthnumber) then   
  424.           begin
  425.           (* there MUST be a figure with a higher number deeper *)
  426.           while ((p^.kind <> Afigure) and (p^.nextitem <> nil)) do
  427.             begin
  428.             p := p^.nextitem;
  429.             end;
  430.  
  431.           if (p^.kind = Afigure) then
  432.             begin
  433.             i := p;
  434.             p := i^.body^.things;
  435.             end
  436.           else
  437.         begin
  438.         complain (ERRREALBAD);
  439.             writeln(logfile,'OOPS p^.kind isnt a figure. It must be near endoflist');
  440.         end;
  441.           end;
  442.         end;  (* while *)
  443.  
  444.       (* we have the correct front of list-list,
  445.          and i points to Afigure item *)
  446.       newthing^.nextitem := p;
  447.       i^.body^.things := newthing;
  448. 101:
  449. end;  (*  pushItem *)
  450.  
  451.  
  452.  
  453. {---------------------------------------------}
  454. function Tgetfixword (k: integer) : real;
  455. var a : 0 .. 4096;
  456.     f : integer;
  457. begin
  458.   a := (tfm[k] * 16) + (tfm[k + 1] div 16);
  459.   f := ((((tfm[k + 1] mod 16) * 256)
  460.          + tfm[k + 2]) * 256)
  461.          + tfm[k + 3];
  462.   if (a > 2047) then
  463.     begin
  464.     a := 4096 - a;
  465.     if (f > 0) then
  466.       begin
  467.       f := TWO20 - f;
  468.       a := a - 1;
  469.       end;
  470.     end;
  471.   Tgetfixword := a + f / TWO20;
  472. end;
  473.  
  474. {-----------------------------------------------------}
  475. function TgetSigned (k: integer): integer;
  476. var i: integer;
  477. begin 
  478.   i := tfm[k];
  479.   if (i < 128) then
  480.     i := i - 256;
  481.   TgetSigned := (((((i * 256) + tfm[k + 1]) * 256) +
  482.                         tfm[k + 2]) * 256) + tfm[k + 3];
  483. end;
  484.  
  485.  
  486.  
  487. {-----------------------------------------------------------}
  488. (* open a .tfm file and return the parameters in it.  
  489.  * Used only in conjuction with the vector and music fonts 
  490.  *)
  491. procedure gettfm (tfmfilnam: strng; 
  492.                   var dessize, p1, p2, p3, p4, p5, p6, p7 : ScaledPts;
  493.                   var cksum : integer);
  494. label 9999;
  495. var tfmptr: integer;
  496.     lf, lh, bc, ec, nw, nh, nd, ni, nl, nk, ne, np: integer;
  497.     charbase, widthbase, heightbase, depthbase,
  498.     italicbase, ligkernbase, kernbase, extenbase,
  499.     parambase : integer;
  500.     tempdesignsize : ScaledPts;
  501. begin
  502.   p1 := 0; p2 := 0; p3 := 0; p4 := 0;
  503.   p5 := 0; p6 := 0; p7 := 0;
  504.   cksum := -1;
  505.  
  506.   strcopy(tfmfilnam.str,  tfmname.str, tfmfilnam.len);
  507.   tfmname.len := tfmfilnam.len;
  508.  
  509.   tfmname.str[tfmname.len + 1] := chr(32);
  510.  
  511.   if (not opentfmfile) then
  512.     begin
  513.       complain (ERRREALBAD);
  514.       writestrng(tfmname,true);
  515.       writeln(logfile,'---not loaded, TFM file can''t be opened!');
  516.       writestrng(tfmname,false);
  517.       writeln(' cannot be opened. Aborting');
  518.       jumpout;
  519.     end;
  520.  
  521.  
  522.   tfm[0] := Tgetvaxbyte;
  523.   tfm[1] := Tgetvaxbyte;
  524.  
  525.  
  526.   lf := (tfm[0] * 256) + tfm[1];
  527.   if ((4 * lf - 1) > TFMSIZE) then 
  528.     begin
  529.     complain (ERRREALBAD);
  530.     write(logfile,'The tfm file:');
  531.     writestrng(tfmfilnam, true);
  532.     writeln(logfile,' is bigger than I can handle!');
  533.     goto 9999;
  534.     end;
  535.  
  536.   for tfmptr := 2 to (4 * lf) - 1 do 
  537.     begin
  538.  
  539.     tfm[tfmptr] := Tgetvaxbyte;
  540.  
  541.     end; (* for *)
  542.  
  543.   tfmptr := 2;
  544.   lh := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  545.   tfmptr := tfmptr + 2;
  546.  
  547.   bc := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  548.   tfmptr := tfmptr + 2;
  549.  
  550.   ec := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  551.   tfmptr := tfmptr + 2;
  552.  
  553.   nw := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  554.   tfmptr := tfmptr + 2;
  555.  
  556.   nh := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  557.   tfmptr := tfmptr + 2;
  558.  
  559.   nd := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  560.   tfmptr := tfmptr + 2;
  561.  
  562.   ni := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  563.   tfmptr := tfmptr + 2;
  564.  
  565.   nl := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  566.   tfmptr := tfmptr + 2;
  567.  
  568.   nk := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  569.   tfmptr := tfmptr + 2;
  570.  
  571.   ne := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  572.   tfmptr := tfmptr + 2;
  573.  
  574.   np := (tfm[tfmptr] * 256) + tfm[tfmptr + 1];
  575.   tfmptr := tfmptr + 2;
  576.  
  577.   if (lf <> (6 + lh + ((ec - bc) + 1) + nw + nh
  578.                           + nd + ni + nl + nk + ne + np)) then 
  579.     begin
  580.       complain (ERRREALBAD);
  581.       writestrng(tfmfilnam, true);
  582.       writeln(logfile,': subfile sizes don''t add up to the stated total!');
  583.       writeln(logfile,'Sorry, but I can''t go on; are you sure this is a TFM?');
  584.       goto 9999
  585.     end;
  586.   if (bc > (ec + 1)) or (ec > 255) then 
  587.     begin
  588.       complain (ERRREALBAD);
  589.       writeln(logfile,'The character code range ', bc: 1, '..', ec: 1, 'is illegal!');
  590.       writeln(logfile,'Sorry, but I can''t go on; are you sure this is a TFM?');
  591.       goto 9999;
  592.     end;
  593.   charbase := (6 + lh) - bc;
  594.   widthbase := (charbase + ec) + 1;
  595.   heightbase := widthbase + nw;
  596.   depthbase := heightbase + nh;
  597.   italicbase := depthbase + nd;
  598.   ligkernbase := italicbase + ni;
  599.   kernbase := ligkernbase + nl;
  600.   extenbase := kernbase + nk;
  601.   parambase := (extenbase + ne) - 1;
  602.  
  603.   dessize := round (Tgetfixword (28) * SPPERPT); (* now in ScaledPts *)
  604.   tempdesignsize := round (dessize * magfactor);
  605.   cksum := TgetSigned (24);
  606.           (* return the special 7 parameters for the  font *)
  607.   p1 := round (Tgetfixword (4 * (parambase + 1)) * tempdesignsize);
  608.   p2 := round (Tgetfixword (4 * (parambase + 2)) * tempdesignsize);
  609.   p3 := round (Tgetfixword (4 * (parambase + 3)) * tempdesignsize);
  610.   p4 := round (Tgetfixword (4 * (parambase + 4)) * tempdesignsize);
  611.   p5 := round (Tgetfixword (4 * (parambase + 5)) * tempdesignsize);
  612.   p6 := round (Tgetfixword (4 * (parambase + 6)) * tempdesignsize);
  613.   p7 := round (Tgetfixword (4 * (parambase + 7)) * tempdesignsize);
  614.  
  615. 9999:
  616. end;
  617.  
  618.  
  619. {---------------------------------------------------}
  620. procedure initVnMnLtables;
  621. var i: integer;
  622. begin
  623.   for i := 1 to SizVFontTable do
  624.     VFontTable[i] := nil;
  625.   for i := 1 to SizMFontTable do
  626.     MFontTable[i] := nil;
  627.   for i := 1 to SizLFontTable do
  628.     LFontTable[i] := nil;
  629.   VFontsDefd := 0;
  630.   MFontsDefd := 0;
  631.   LFontsDefd := 0;
  632.   GDVIFN := 300; (* starting number for any new fonts that we define *)
  633. end; 
  634.  
  635.  
  636. {-------------------------------------------------------}
  637. procedure fonttobedefined (kind : char; findex : integer);
  638. begin
  639.   FTBDs := FTBDs + 1;  
  640. (* reset this to zero after outputting
  641.    1. fontdefs
  642.    2. bop
  643.    3. contents of dvi page
  644.    4. eop
  645. *)
  646.   TBD[FTBDs].which := kind;
  647.   TBD[FTBDs].indx := findex;
  648. end;
  649.  
  650.  
  651. {-----------------------------------------------------}
  652. procedure enterfont (fontnum : integer; ck : integer;
  653.                      scalefact, dessiz : ScaledPts;
  654.                      nam : strng);
  655. var n: integer;
  656.     len : integer;
  657. begin
  658.   cmd1byte(FONTDEF);
  659.   cmd2byte(fontnum);
  660.   cmd4byte(ck);
  661.   cmd4byte(scalefact);
  662.   cmd4byte(dessiz);
  663.   cmd1byte(USESTDAREA);
  664.  
  665.   len := nam.len;
  666.  
  667.  
  668.   cmd1byte(len - 4); (* skip the length of the .tfm suffix *)
  669.  
  670.  
  671.   for n := 1 to (nam.len - 4) do    
  672.  
  673.     begin (* skip the .tfm suffix *)
  674.     cmd1byte (xord [ nam.str[n] ]);
  675.     end;
  676. end;
  677.  
  678.  
  679. {-----------------------------------------------------}
  680. procedure Outputfont (fontnum : integer; ck : integer;
  681.                      scalefact, dessiz : ScaledPts;
  682.                      nam : strng);
  683. var n: integer;
  684.     len : integer;
  685. begin
  686.   OutputByte(FONTDEF);
  687.   Output2Byte(fontnum);
  688.   Output4Byte(ck);
  689.   Output4Byte(scalefact);
  690.   Output4Byte(dessiz);
  691.   OutputByte(USESTDAREA);
  692.  
  693.   len := nam.len;
  694.  
  695.  
  696.   OutputByte(len - 4);
  697.  
  698.  
  699.   for n := 1 to (nam.len - 4) do    
  700.  
  701.     begin (* dont output the default dir prefix, nor the .tfm suffix *)
  702.     OutputByte(xord [ nam.str[n] ]);
  703.     end;
  704. end;
  705.  
  706. {-----------------------------------------------------}
  707. procedure defineNewfonts;
  708. (* this needs to be done before first access to a font on a page
  709.   later someone else will have to re-define all of them in the postamble *)
  710. label 99;
  711. var i, n : integer;
  712.     f : integer;
  713. begin
  714.   for i := 1 to FTBDs do
  715.     begin
  716.     if (TBD[i].which = 'V') then
  717.       begin
  718.       f := TBD[i].indx;
  719.       with VFontTable[f]^ do  
  720.         begin
  721.         if (Isdefined) then
  722.          goto 99;
  723.         Outputfont (DVIFontNum, Cksum, DesSize, DesSize, 
  724.                         FontName);
  725.         Isdefined := true;
  726.         end; (*with *)
  727.       end (* if *)
  728.     else if (TBD[i].which = 'M') then
  729.       begin (* music font *)
  730.       f := TBD[i].indx;
  731.       with MFontTable[f]^ do
  732.         begin
  733.         if (Isdefined) then
  734.          goto 99;
  735.         Outputfont (DVIFontNum, Cksum, DesSize, DesSize,
  736.                         FontName);
  737.         Isdefined := true;
  738.         end; (* with *)
  739.       end (* else *)
  740.     else if (TBD[i].which = 'L') then
  741.       begin (* label font *)
  742.       f := TBD[i].indx;
  743.       with LFontTable[f]^ do
  744.     begin
  745.     if (Isdefined) then
  746.       goto 99;
  747.     Outputfont (DVIFontNum, Cksum, DesSize, DesSize, {### is this right?}
  748.             FontName);
  749.     Isdefined := true;
  750.     end;  (* with *)
  751.       end 
  752.     else
  753.       begin
  754.       complain (ERRREALBAD);
  755.       writeln(logfile,'Unknown type of font to be defined:"',TBD[i].which,'"');
  756.       end;  (* else *)
  757. 99:
  758.     end; (* for *)
  759. end; 
  760.  
  761.  
  762. {---------------------------------------------------}
  763. function GetMusFont (stfsiz, fam : integer) : MusIndex;
  764. label 20, 99;
  765. var mustfmnam : strng;
  766.     found, i : MusIndex;
  767.     design, p1, p2, p3, p4, linesp, gwidth, p7 : ScaledPts;
  768.     cksm, r, k : integer;
  769. begin
  770.   (* see if it already exists *)
  771.   found := 0;
  772.   for i := 1 to MFontsDefd do  (* loop through since there are few *)
  773.     with MFontTable[i]^ do
  774.       begin
  775.       if (Staffsize = stfsiz) and
  776.          (Family = fam) then
  777.          begin
  778.          found := i;
  779.          goto 20;
  780.          end;
  781.       end; (* with *)
  782.   
  783. 20: if (found <> 0) then
  784.      begin
  785.      GetMusFont := found;
  786.      goto 99;
  787.      end;
  788.     
  789.     (* Not here already--go get it *)
  790.     for k := 1 to ARRLIMIT do
  791.       mustfmnam.str[k] := ' ';
  792.  
  793.     r := 0;
  794.  
  795.     mustfmnam.str[r+1] := 'm';
  796.     mustfmnam.str[r+2] := 'u';
  797.     mustfmnam.str[r+3] := 's';
  798.     mustfmnam.str[r+4] := xchr[stfsiz + xord['0']];
  799.     mustfmnam.str[r+5] := xchr[fam + xord['0']];
  800.     mustfmnam.str[r+6] := '.';
  801.     mustfmnam.str[r+7] := 't';
  802.     mustfmnam.str[r+8] := 'f';
  803.     mustfmnam.str[r+9] := 'm';    
  804.  
  805.     mustfmnam.str[r+10] := chr(32);
  806.  
  807.     mustfmnam.len := 9 + r;
  808.     gettfm (mustfmnam, design, p1, p2, p3, p4, linesp, gwidth, p7, cksm);
  809.  
  810.     MFontsDefd := MFontsDefd + 1;
  811.    if (MFontsDefd > SizMFontTable) then
  812.      begin
  813.        complain (ERRREALBAD);
  814.        writestrng(mustfmnam, true);
  815.        writeln(logfile,'---not loadable. Size of Music Font table too small');
  816.        writestrng(mustfmnam,false);
  817.        writeln(' cannot be loaded. Too many music fonts. Table too small.');
  818.        jumpout;
  819.      end;
  820.  
  821.     i := MFontsDefd;
  822.     new (MFontTable[i]);
  823.     with MFontTable[i]^ do
  824.       begin
  825.       Staffsize := stfsiz;    
  826.       Family := fam;
  827.       DesSize := design;
  828.       strcopy (mustfmnam.str, FontName.str, mustfmnam.len);
  829.       FontName.len := mustfmnam.len;
  830.       Cksum := cksm;
  831.       ghu := round (gwidth / QNOTEGHUS);
  832.       gvu := round (linesp / QNOTEGVUS);
  833.       DVIFontNum := GDVIFN + 1;
  834.       Isdefined := false;
  835.       end;
  836.  
  837.     GDVIFN := GDVIFN + 1;
  838. (* call someone to do the defns of cdp, cht, cwd foreach beam *)      
  839.     definebeams (MFontTable[i]);
  840.     fonttobedefined ('M', i);
  841.     GetMusFont := i;
  842. 99:    
  843. end; 
  844.  
  845.  
  846. {---------------------------------------------------}
  847. function GetVectFont (size : VThickness; vk : VectKind) : VecIndex;
  848. label 20, 99;
  849. var vectfmnam : strng;
  850.     found, i : VecIndex;
  851.     design, p1, p2, w0, w1, maxveclen, p6, p7 : ScaledPts;
  852.     cksm, r, k : integer;
  853. begin
  854.   (* see if it already exists *)
  855.   found := 0;
  856.  
  857.   for i := 1 to VFontsDefd do
  858.    with VFontTable[i]^ do
  859.     begin
  860.     if ((psize = size) and
  861.         (vkind = vk)) then
  862.        begin
  863.        found := i;
  864.        goto 20;
  865.        end;
  866.     end; (* with *)
  867.     
  868. 20:
  869.   if (found <> 0) then
  870.    begin
  871.      GetVectFont := found;
  872.      goto 99;
  873.    end;
  874.     
  875.     (* Not here--go get it *)
  876.     for k := 1 to ARRLIMIT do
  877.       vectfmnam.str[k] := ' ';
  878.  
  879.     r := 0;
  880.  
  881.     case (vk) of
  882.       VKCirc : vectfmnam.str[r+1] := 'c';
  883.       VKVert : vectfmnam.str[r+1] := 'v';
  884.       VKHort : vectfmnam.str[r+1] := 'h';
  885.     end; (*case *)
  886.     vectfmnam.str[r+2] := 'v';
  887.     vectfmnam.str[r+3] := 'e';
  888.     vectfmnam.str[r+4] := 'c';
  889.      if (size <= 9) then
  890.       begin
  891.       vectfmnam.str[r+5] := xchr[size + xord['0']];
  892.       vectfmnam.str[r+6] := '.';
  893.       vectfmnam.str[r+7] := 't';
  894.       vectfmnam.str[r+8] := 'f';
  895.       vectfmnam.str[r+9] := 'm';
  896.  
  897.       vectfmnam.str[r+10] := chr(32);      
  898.  
  899.       vectfmnam.len := 9 + r;
  900.       end
  901.     else
  902.       begin
  903.       vectfmnam.str[r+5] := xchr[(size div 10) + xord['0']];
  904.       vectfmnam.str[r+6] := xchr[(size - ((size div 10)*10)) + xord['0']];
  905.       vectfmnam.str[r+7] := '.';
  906.       vectfmnam.str[r+8] := 't';
  907.       vectfmnam.str[r+9] := 'f';
  908.       vectfmnam.str[r+10] := 'm';
  909.  
  910.       vectfmnam.str[r+11] := chr(32);      
  911.  
  912.       vectfmnam.len := 10 + r;
  913.       end;
  914.  
  915.    gettfm (vectfmnam, design, p1, p2, w0, w1, maxveclen, p6, p7, cksm);
  916.    VFontsDefd := VFontsDefd + 1;
  917.    if (VFontsDefd > SizVFontTable) then
  918.      begin
  919.        complain (ERRREALBAD);
  920.        writestrng(vectfmnam, true);
  921.        writeln(logfile,'---not loadable. Size of Vector Font table too small');
  922.        writestrng(vectfmnam,false);
  923.        writeln(' cannot be loaded. Too many vector fonts. Table too small.');
  924.        jumpout;
  925.      end;
  926.  
  927.    i := VFontsDefd;
  928.    new (VFontTable[i]);
  929.    with VFontTable[i]^ do
  930.      begin
  931.      vkind := vk;
  932.      psize := size;
  933.      DesSize := design;
  934.      if (vk = VKVert) then
  935.        PenSize := w1    
  936.      else
  937.        PenSize := w0;
  938.      PenSize := round (size * (MAXVECLENsp / 16.0));
  939.      MaxVectLen := maxveclen;
  940.      strcopy (vectfmnam.str, FontName.str, vectfmnam.len);
  941.      FontName.len := vectfmnam.len;
  942.      Cksum := cksm;
  943.      Isdefined := false;
  944.      DVIFontNum := GDVIFN + 1;
  945.      end;
  946.  
  947.   GDVIFN := GDVIFN + 1;
  948.  
  949.   definevectors (VFontTable[i]);
  950. (* someone asked for it, so they must want it, and we should fntdef it *)
  951.   fonttobedefined ('V', i); 
  952.   GetVectFont := i;
  953. 99:
  954. end;
  955.  
  956. {----------------------------------------------------------}
  957. function GetLabFont (style : integer) : integer;
  958. label 30, 99;
  959. var labtfmnam : strng;
  960.     found, i : integer;
  961.     design, p1, space, p3, p4, p5, p6, p7 : ScaledPts;
  962.     cksm, r, k : integer;
  963. begin
  964. if (style > MAXLABELFONTS) then
  965.   style := 1;
  966.   found := 0;
  967.   for i := 1 to LFontsDefd do
  968.     with LFontTable[i]^ do
  969.       begin
  970.       if (internalnumber = style) then
  971.     begin
  972.         found := i;
  973.     goto 30;
  974.     end;
  975.       end; 
  976. 30:
  977.    if (found <> 0) then
  978.      begin
  979.      GetLabFont := found;
  980.      goto 99;
  981.      end;  
  982.    for k := 1 to ARRLIMIT do
  983.      labtfmnam.str[k] := ' ';
  984.  
  985.    r := 0;
  986.  
  987.    labtfmnam.str[r + 1] := 'c';
  988.    labtfmnam.str[r + 2] := 'm';
  989.    case style of
  990.      1: begin        (* cmtt10 *)
  991.         labtfmnam.str[r + 3] := 't';
  992.         labtfmnam.str[r + 4] := 't';
  993.         labtfmnam.str[r + 5] := '1';
  994.         labtfmnam.str[r + 6] := '0';
  995.     k := r + 6;
  996.         end;
  997.      2: begin        (* cmb10 *)
  998.         labtfmnam.str[r + 3] := 'b';
  999.         labtfmnam.str[r + 4] := '1';
  1000.         labtfmnam.str[r + 5] := '0';
  1001.